home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / urlFace.tcl.z / urlFace.tcl
Text File  |  2002-07-08  |  8KB  |  288 lines
  1. # urlFace.tcl
  2. #
  3. # Author: Ovidiu Predescu <ovidiu@aracnet.com>
  4. #
  5. # Retrieve an image giving an URL and use it as face.
  6.  
  7. set urlFace(width) 48
  8. set urlFace(height) 48
  9.  
  10. # Some private procedures for this module
  11.  
  12. proc UrlGetCachedImageFileName { href } {
  13.     global urlFace
  14.  
  15.     set extension [file extension $href]
  16.  
  17.     if [catch {exec echo $href | sed -e s^/^_^g} trhref] {
  18.     UrlFaceLog "cannot process URL! ($trhref)"
  19.     # Cannot process the URL; create a temp file to hold the image
  20.     set trhref "temp.$extension"
  21.     }
  22.     set rootname [file rootname $trhref]
  23.  
  24.     # Handle image types not currently known by Tk. This requires the
  25.     # PPM tools to work. We use a PPM conversion of the file instead
  26.     # of the original file.
  27.  
  28.     switch -- $extension {
  29.     .tiff - .tif - .jpeg - .jpg - .pbm - .xbm {
  30.         set trhref "$rootname.ppm"
  31.     }
  32.  
  33.     .pnm - .ppm - .pgm - .gif - .xpm {
  34.         # Do nothing
  35.     }
  36.  
  37.     default {
  38.         Exmh_Status "Image type $extension not supported!" red
  39.         UrlFaceLog "Image type $extension not supported!"
  40.         return ""
  41.     }
  42.     }
  43.  
  44.     set cachedImagesDir "[glob ~]/.exmh/exmh-images"
  45.     if {![file exists $cachedImagesDir]} {
  46.     exec mkdir $cachedImagesDir
  47.     }
  48.     set imageFile "$cachedImagesDir/$trhref"
  49.  
  50.     return $imageFile
  51. }
  52.  
  53. # Transform unknown image file formats to PPM. All the images are
  54. # converted to the size urlFace(width) x $urlFace(height).
  55. proc UrlFaceGetNormalizedImage { filename } {
  56.     global urlFace
  57.  
  58.     set filename [glob $filename]
  59.     set extension [file extension $filename]
  60.     set rootname [file rootname $filename]
  61.  
  62.     switch -- $extension {
  63.     .tiff - .tif {
  64.         if [catch {exec tifftopnm <$filename 2>/dev/null \
  65.                | pnmscale -xysize $urlFace(width) $urlFace(height) \
  66.                >${rootname}.ppm} err] {
  67.         Exmh_Status "cannot convert TIFF file! ($err)" red
  68.         UrlFaceLog "cannot convert TIFF file! ($err)"
  69.         return "";
  70.         } else {
  71.         return ${rootname}.ppm
  72.         }
  73.     }
  74.  
  75.     .jpeg - .jpg {
  76.         if [catch {exec djpeg -pnm $filename \
  77.                | pnmscale -xysize $urlFace(width) $urlFace(height) \
  78.                >${rootname}.ppm} err] {
  79.         Exmh_Status "cannot convert JPEG file! ($err)" red
  80.         UrlFaceLog "cannot convert JPEG file! ($err)"
  81.         return "";
  82.         } else {
  83.         return ${rootname}.ppm
  84.         }
  85.     }
  86.  
  87.     .xbm {
  88.         if [catch {exec xbmtopbm <$filename \
  89.                | pnmscale -xysize $urlFace(width) $urlFace(height) >${rootname}.ppm 2>/dev/null} err] {
  90.         Exmh_Status "cannot convert XBM file! ($err)" red
  91.         UrlFaceLog "cannot convert XBM file! ($err)"
  92.         return "";
  93.         } else {
  94.         return ${rootname}.ppm
  95.         }
  96.     }
  97.  
  98.     .pbm {
  99.         if [catch {exec pnmscale -xysize $urlFace(width) $urlFace(height) <$filename \
  100.                >${rootname}.ppm 2>/dev/null} err] {
  101.         Exmh_Status "cannot scale PBM file! ($err)" red
  102.         UrlFaceLog "cannot scale PBM file! ($err)"
  103.         return "";
  104.         } else {
  105.         return ${rootname}.ppm
  106.         }
  107.     }
  108.  
  109.  
  110.     .pnm - .ppm - .pgm {
  111.         set image [image create photo -file $filename]
  112.  
  113.         # Scale the image if its different than
  114.         # $urlFace(width) x $urlFace(height)
  115.         set height [image height $image]
  116.         set width [image width $image]
  117.  
  118.         if {($height != $urlFace(height) || $width != $urlFace(width))
  119.         && [catch {exec sh -c "pnmscale -xysize $urlFace(width) $urlFace(height) <$filename \
  120.                    >${filename}.new \
  121.                    && mv $filename.new ${filename}"} err]} {
  122.         Exmh_Status "cannot scale PPM file! ($err)" red
  123.         UrlFaceLog "cannot scale PPM file! ($err)"
  124.         }
  125.         return $filename;
  126.     }
  127.  
  128.     .gif {
  129.         set image [image create photo -file $filename]
  130.  
  131.         # Scale the image if its different than
  132.         # $urlFace(width) x $urlFace(height)
  133.         set height [image height $image]
  134.         set width [image width $image]
  135.  
  136.         if {($height != $urlFace(height) || $width != $urlFace(width))
  137.         && [catch {exec sh -c "(giftopnm <$filename \
  138.                    | pnmscale -xysize $urlFace(width) $urlFace(height) \
  139.                    | ppmquant 256 \
  140.                    | ppmtogif >${filename}.new \
  141.                    && mv ${filename}.new ${filename}\
  142.                    && exit 0)" 2>/dev/null} err]} {
  143.         Exmh_Status "cannot scale GIF file! ($err)" red
  144.         UrlFaceLog "cannot scale GIF file! ($err)"
  145.         }
  146.         return $filename
  147.     }
  148.  
  149.     .xpm {
  150.         set image [image create photo -file $filename]
  151.  
  152.         # Scale the image if its different than
  153.         # $urlFace(width) x $urlFace(height)
  154.         set height [image height $image]
  155.         set width [image width $image]
  156.  
  157.         if {($height != $urlFace(height) || $width != $urlFace(width))
  158.         && [catch {exec sh -c "(xpmtoppm <$filename \
  159.                    | pnmscale -xysize $urlFace(width) $urlFace(height) \
  160.                    | ppmquant 256 \
  161.                    | ppmtoxpm >${filename}.new \
  162.                    && mv ${filename}.new ${filename})" 2>/dev/null} err]} {
  163.         Exmh_Status "cannot scale XPM file! ($err)" red
  164.         UrlFaceLog "cannot scale XPM file! ($err)"
  165.         }
  166.         return $filename;
  167.     }
  168.  
  169.     }
  170.  
  171.     return $filename
  172. }
  173.  
  174. proc UrlFaceQueryStatus {state count length} {
  175.     global exmh urlFace failedURLs
  176.     upvar url href
  177.  
  178.     if {![string compare $state "error"]} {
  179.     # error reading from URL
  180.     Exmh_Status "error reading $href! ($count)" red
  181.     UrlFaceLog "error reading $href! ($count)"
  182.     set urlFace($href,urlFailed) 1
  183.     lappend failedURLs $href
  184.     FaceShowFile $exmh(library)/loaderror.ppm $urlFace($href,pane)
  185.     return
  186.     } elseif {![string compare $state "body"]} {
  187.     # The URL does not exist
  188.     UrlFaceLog "URL $href does not exist!"
  189.     FaceShowFile $exmh(library)/loaderror.ppm $urlFace($href,pane)
  190.     set urlFace($href,urlFailed) 1
  191.     lappend failedURLs $href
  192.     return
  193.     }
  194.  
  195.     if {$length} {
  196.     Exmh_Status [format "%s... %.1f%% complete" \
  197.              $href [expr 100.0 * $count / $length]]
  198.     } else {
  199.     Exmh_Status [format "%s..." $href]
  200.     }
  201. }
  202.  
  203. proc UrlFaceQueryDone { href filename msgPath pane } {
  204.     global exmh urlFace msg
  205.     upvar #0 $href data
  206.  
  207.     unset urlFace($href,pane)
  208.  
  209.     if {[info exists urlFace($href,urlFailed)]} {
  210.     unset urlFace($href,urlFailed)
  211.     } else {
  212.     UrlFaceLog "got image from $href in $data(file)"
  213.     set normalized [UrlFaceGetNormalizedImage $data(file)]
  214.     UrlFaceLog "normalized file is $normalized"
  215.  
  216.     UrlFaceLog "executing cp [glob $normalized] $filename"
  217.     if [catch {exec cp [glob $normalized] $filename} err] {
  218.         Exmh_Status "cannot create face file in ~/.exmh/exmh-images! ($err)" red
  219.         UrlFaceLog "cannot create face file in ~/.exmh/exmh-images! ($err)"
  220.         FaceShowFile $exmh(library)/loaderror.ppm $pane
  221.         return
  222.     }
  223.  
  224.     # Display the face if the current message is the same
  225.     if {$msg(path) == $msgPath} {
  226.         Url_displayFace $href $filename $pane
  227.     }
  228.     }
  229. }
  230.  
  231. proc Url_displayFace { href imageFile {pane {}} } {
  232.     global exmh failedURLs
  233.  
  234.     Exmh_Status "Displaying face..."
  235.     UrlFaceLog "displaying face from $imageFile"
  236.     if ![FaceShowFile $imageFile $pane] {
  237.     # Remove the cached image in case of errors
  238.     catch {exec rm -f $imageFile}
  239.     lappend failedURLs $href
  240.     FaceShowFile $exmh(library)/loaderror.ppm $pane
  241.     return 0
  242.     } else {
  243.     Exmh_Status "Displaying face...done"
  244.     return 1
  245.     }
  246. }
  247.  
  248. # This is the public procedure in this file
  249. proc UrlDisplayFace { href pane } {
  250.     global urlFace msg failedURLs exmh
  251.  
  252.     set imageFile [UrlGetCachedImageFileName $href]
  253.  
  254.     # Check to see if the file is already cached
  255.     if {[string compare $imageFile ""]
  256.     && ![file exists $imageFile]} {
  257.     # The image is not cached, retrieve it. Since this may take a
  258.     # while we simply return with the appropriate return code. The
  259.     # face will be displayed when the loading of the image is
  260.     # finished.
  261.  
  262.     set urlFace($href,pane) $pane
  263.     FaceShowFile $exmh(library)/loading.ppm $pane
  264.  
  265.     Exmh_Status "getting image face from $href..."
  266.     UrlFaceLog "getting image face from $href..."
  267.     set ret [Http_get $href \
  268.          "UrlFaceQueryDone $href $imageFile $msg(path) $pane" \
  269.          UrlFaceQueryStatus]
  270.     if {![string compare $ret ""]} {
  271.         # URL could not be reached. Disable the access to it
  272.         # during this session.
  273.         Exmh_Status "unable to display the X-Image-Url face!" red
  274.         UrlFaceLog "unable to display the X-Image-Url face!"
  275.         FaceShowFile $exmh(library)/loaderror.ppm $pane
  276.         lappend failedURLs $href
  277.     }
  278.     UrlFaceLog "delayed showing the image from $href"
  279.     return 0
  280.     } else {
  281.     return [Url_displayFace $href $imageFile $pane]
  282.     }
  283. }
  284.  
  285. proc UrlFaceLog {args} {
  286. #    puts $args
  287. }
  288.